home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Internet Surfer: Getting Started
/
Internet Surfer - Getting Started (Wayzata Technology)(7231)(1995).bin
/
pc
/
mac
/
bonus
/
peter_le
/
dehqx-20
/
dehqx.p
< prev
next >
Wrap
Text File
|
1991-08-23
|
9KB
|
358 lines
unit DeHQX;
{ DeHQX v2.0.0 ⌐ Peter Lewis, Aug 1991 }
interface
uses
MyTypes, MyFileSystem, MyStandardFile, AppGlobals, CRCs, MyUtilities, MyMainLoop, {}
SmallEvents, MyNotifier, MyMenus, Displays, HQXLists, ReadHQX, DisplayHQX, {}
MySystem7, Preferences;
procedure DeHQXFiles;
procedure DeHQXList;
procedure DeHQXParameters;
procedure AddFolder (vrn: integer; dirID: longInt);
implementation
const
update_period = 1024;
display_updates = 1024 div update_period;
function DoFork (vrn: integer; dirID: longInt; var name: str63; {}
wp: windowPtr; fork: forkType; len: longInt): OSErr;
type
updateRange = 0..update_period;
var
oe, ooe: OSErr;
thecrc, actcrc: integer;
i: longInt;
j: integer;
b: byte;
outfile: integer;
buffer: packed array[updateRange] of byte;
bptr: updateRange;
blen: longInt;
procedure SimpleHandleUpdateEvents;
var
reply: HEReply;
begin
HandleCancelErrorEvents(0, nil, oe, reply);
if reply.todo = T_Update then begin
BeginUpdate(wp);
DisplayUpdate(wp);
EndUpdate(wp);
end;
end;
begin
crc := 0;
if fork = data_fork then
oe := MFSOpenDF(outfile, vrn, dirID, name, POut)
else
oe := MFSOpenRF(outfile, vrn, dirID, name, POut);
DisplayFork(wp, fork, 0, oe);
SimpleHandleUpdateEvents;
if oe = noErr then begin
for i := 1 to len div update_period do begin
bptr := 0;
for j := 1 to update_period do begin
oe := ReadByte(b);
if oe <> noErr then
leave;
buffer[bptr] := b;
bptr := bptr + 1;
end;
if oe = noErr then begin
blen := bptr;
oe := FSWrite(outfile, blen, @buffer);
end;
if oe <> noErr then
leave;
SimpleHandleUpdateEvents;
if oe <> noErr then
leave;
if i mod display_updates = 0 then
DisplayFork(wp, fork, i * update_period, oe);
end;
if oe = noErr then begin
bptr := 0;
for j := 1 to len mod update_period do begin
oe := ReadByte(b);
if oe <> noErr then
leave;
buffer[bptr] := b;
bptr := bptr + 1;
end;
if oe = noErr then begin
blen := bptr;
oe := FSWrite(outfile, blen, @buffer);
end;
end;
CalcCRC(crc, 0);
CalcCRC(crc, 0);
actcrc := crc;
if oe = noErr then
oe := ReadInteger(thecrc);
if (actcrc <> thecrc) and (oe = noErr) then
oe := HqxFormatErr;
DisplayFork(wp, fork, len, oe);
ooe := FSClose(outfile);
end;
DoFork := oe;
end;
procedure DeHQXList;
const
fin_err = 1;
var
reply: MySFReply;
oe, ooe: integer;
hi: hqxInfo;
wp: windowPtr;
any_saved, any_errors, first_save: boolean;
alertID, alertButton: integer;
dummy_name: str255;
prompting: promptStates;
savefolder: boolean;
ovrn: integer;
odirID: longInt;
did_something: boolean;
fdel, fstop: boolean;
procedure SetFirstSave (vrn: integer; dirID: longInt);
begin
if first_save then begin
SetSFFile(vrn, dirID);
first_save := false;
end;
end;
procedure Interact;
var
oe: OSErr;
begin
oe := MyInteractWithUser(nil);
end;
begin
if AnyInputFiles then begin
OpenDisplay(wp);
first_save := true;
prompting := prefs.prompt_state;
oe := noErr;
while AnyInputFiles and (oe <> cancelErr) do begin
did_something := true;
StartList;
savefolder := false;
any_saved := false;
any_errors := false;
oe := OpenHQX;
while oe = noErr do begin
oe := ReadHeader(hi, wp);
if oe = noErr then begin
with reply do begin
RfName := hi.name;
Rgood := true;
if savefolder then begin
RvRefNum := ovrn;
RdirID := odirID;
end
else
CreateFolder(RvRefNum, RdirID);
case prompting of
PS_Always:
begin
Interact;
SetFirstSave(RvRefNum, RdirID);
PutFolder(GetGlobalString(sfput_string), RfName, put_folder_id, reply);
if Rgood and Rfolder then begin
if RfName = '' then begin
RfName := hi.name;
MFSUniqueName(RvRefNum, RdirID, RfName); { cant really put up another dialog box! }
end;
savefolder := true;
prompting := PS_Exists;
ovrn := RvRefNum;
odirID := RdirID;
end;
end;
PS_Exists:
if MFSExists(RvRefNum, RdirID, RfName) then begin
Interact;
SetSFFile(RvRefNum, RdirID);
PutFolder(GetGlobalString(sfput_string), RfName, put_folder_id, reply);
if Rgood then begin
if Rfolder then begin
savefolder := true;
ovrn := RvRefNum;
odirID := RdirID;
end
else begin
savefolder := false;
prompting := prefs.prompt_state;
end;
end;
end;
PS_Skip:
Rgood := not MFSExists(RvRefNum, RdirID, RfName);
PS_Overwrite:
;
PS_Unique:
MFSUniqueName(RvRefNum, RdirID, RfName);
end; {case}
if not Rgood then
cycle;
with hi do begin
name := RfName;
wdrn := RvRefNum;
dirID := RdirID;
DisplayOpen(wp, hi);
if oe = noErr then
oe := MFSCreate(RvRefNum, RdirID, RfName, c, t);
if oe = noErr then
oe := DoFork(RvRefNum, RdirID, RfName, wp, data_fork, dlen);
if oe = noErr then
oe := DoFork(RvRefNum, RdirID, RfName, wp, rsrc_fork, rlen);
if oe = noErr then begin
oe := ReadColon;
end;
DisplayFinish(wp, oe);
end; {with}
if oe = noErr then begin
any_saved := true;
end
else begin
ParamText(RfName, '', '', '');
any_errors := true;
case oe of
cancelErr:
begin
fdel := true;
fstop := true;
end;
HqxFormatErr:
begin
Interact;
alertButton := Alert(hqx_error_alert_id, nil);
fstop := not odd(alertButton);
fdel := alertButton < 3;
end;
otherwise
begin
Interact;
alertButton := Alert(disk_error_alert_id, nil);
fstop := alertButton = 1;
fdel := true;
end;
end;
if fstop then
oe := cancelErr
else begin
oe := noErr;
quitNow := false;
HiliteMenu(0);
end;
if fdel then
ooe := MFSDelete(RvRefNum, RdirID, RfName);
end;
DisplayClose(wp);
end; {with}
end; {if}
end;
FinishHQX;
FinishList(prefs.delete_state and any_saved and not any_errors);
end;
if did_something then begin
if prefs.auto_quit_state and any_saved and not any_errors then
quitNow := true;
if (oe <> cancelErr) or not in_foreground then begin { No sense beeping and notifying if the user canceled! }
if prefs.beep_state then
SysBeep(3);
if prefs.notify_state and not in_foreground then
Notify(true, false, 128, 1, 0, 0);
end;
end;
CloseDisplay(wp);
size_in_lists := 0;
size_processed := 0;
end;
end;
function HQXHook (var pb: HParamBlockRec): boolean;
begin
case prefs.display_state of
DS_All:
HQXHook := false;
DS_TEXT:
HQXHook := pb.ioFlFndrInfo.fdType <> 'TEXT';
DS_HQX:
HQXHook := (pb.ioFlFndrInfo.fdType <> 'TEXT') or not EqualString(Copy(pb.ioNamePtr^, length(pb.ioNamePtr^) - 2, 3), 'hqx', false, false);
end;
end;
procedure AddFolder (vrn: integer; dirID: longInt);
var
pb: HParamBlockRec;
name: str255;
i: integer;
oe: OSErr;
begin
i := 1;
with pb do
repeat
name := '';
ioNamePtr := @name;
ioVRefNum := vrn;
ioDirID := dirID;
ioFVersNum := 0;
ioFDirIndex := i;
i := i + 1;
oe := PBHGetFInfo(@pb, false);
if oe = noErr then
if not HQXHook(pb) then begin
AddFile(vrn, dirID, name, prefs.create_dir_state <> CDS_Never, pb.ioFlLgLen);
end;
until oe <> noErr;
end;
procedure DeHQXFiles;
var
typeList: SFTypeList;
reply: MySFReply;
ovrn: integer;
dirID: longInt;
oe: OSErr;
begin
GetFolder(@HqxHook, -1, typeList, get_folder_id, reply);
HiliteMenu(0);
with reply do
if Rgood then begin
if not Rfolder then begin
AddFile(RvRefNum, RdirID, RfName, prefs.create_dir_state = CDS_Always, -1);
end
else begin
AddFolder(RvRefNum, RdirID);
end;
end;
end;
procedure DeHQXParameters;
var
paramCount, paramMessage, i: integer;
tf: appFile;
pb: paramBlockRec;
ovrn: integer;
odirID, dirID: longInt;
oe: OSErr;
sh: stringHandle;
begin
CountAppFiles(paramMessage, paramCount);
GetAppFiles(1, tf);
for i := 1 to paramCount do begin
GetAppFiles(i, tf);
if tf.fType <> myAppType then begin
oe := GetDirID(tf.vRefNum, ovrn, odirID);
AddFile(ovrn, odirID, tf.fName, prefs.create_dir_state <> CDS_Never, -1);
ClrAppFiles(i);
end;
end;
end;
end.
